;; File: 			gk.lisp
;; Authors:         Kevin Somers and Griffin Donohue
;; Email:           sokev1@umbc.edu / gd4@umbc.edu
;; Course:			CMSC471 - Introduction to Artificial Intelligence
;; Description: 	Code to define a solver for the game Mastermind
;;					Inspiration for algorithm from:
;;					http://www.unc.edu/~radu/mm/MMS.html

;;sets up package for local code and uses code from :mm
(if (not (find-package :gk)) (make-package :gk))
(in-package :gk)
(use-package :mm)

;;Function: test
;;
;;Used to easily run a test tournament with user-defined parameters.
;;Simply calls :mm's tournament function
(defun test()
  (mm-tournament :colors '(q w e r t y u i) 
		 :code-length 8
		 :gen-fn 'mm-gen-random
		 :players (list *mm-player*) 
		 :rounds 10))

;; GLOBAL VARIABLES

;;creates a seed different from the one used in mm-gen-random
(setf seed (make-random-state t))

;;Knowledge Base - Each segement of the knowledge base contains
;;a previous guess and its red/white peg results
(defvar *knowledge* nil)

;;Highest Knowledge Value - Best (red + white) value in the knowledge base.
(defvar *best-guess* nil)

;;Possible Colors - Possible Colors to select from
(defvar *possible-colors* nil)

;; Player Instance
(defvar *mm-player*)
(setf *mm-player*
			(make-instance 'mm::player :name 'mm-spot-solve :guess-fn 'mm-spot-solve))
			
;; MAIN FUNCTIONS

;;Function: mm-spot-solve
;;
;;This function, originally adapted from the provided "mm-gentest" function in
;;mm-solver.lisp, is the general function for our solver.
;;After guessing, it adds that guess to the knowledge base, checks
;;to see if all reds have been matched, clears the knowledge base and exits if so,
;;and guesses again if not.
(defun mm-spot-solve (&optional (colors *colors*) (code-length *code-length*) (generator #'mm-gen-random) &aux reds whites)
	(clear)
	(setf *possible-colors* (copy-list colors))
	(let ((guess (loop for i from 1 to code-length collect (nth (random (length colors) seed) colors))))
    (loop while guess
	  do (progn
	       (multiple-value-setq (reds whites)
				    (mm-score guess *code* colors))
		   (setf *knowledge* (append *knowledge* (list (cons guess (list reds whites)))))
		   (setf *best-guess* (cons guess (list reds whites)))
	       (cond ((eq reds code-length)
			  (clear)
		      (return-from mm-spot-solve))
		     (t (setf *possible-colors* (update-possible-colors guess (list reds whites) (copy-list *possible-colors*) code-length))
		     		(setf guess (gen-guess guess (copy-list *possible-colors*)
						    code-length))))))))

;;Function: gen-guess
;;
;;Preliminary guesses are randomly generated. If "check-knowledge" returns nil,
;;the random guess is invalid based on the current knowledge base, whether the guess
;;has been tried before, or the guess will stray further away from a N reds score
;;based on the current red/whites score. 
(defun gen-guess (guess colors code-length)
	(setf guess (copy-list guess))
	
	(guess-within-bounds guess colors code-length)
	
	(setf knowledge (copy-list *knowledge*))
	
	(loop while (null (check-knowledge guess knowledge)) do
		(setf guess (copy-list guess))
		(guess-within-bounds guess colors code-length))
		
	(return-from gen-guess guess))

;;Function: guess-within-bounds
;;
;;This function takes the sum of red and white pegs
;;for the best guess so far, and considers the colors
;;of that guess for heavy use in guessing a new guess.
;;For example, if there are 6 white pegs out of 8 spaces,
;;the list of possible colors include those 8 colors plus
;;two NILs, representing the incorrect colors in the guess.
;;This makes it more efficient in guessing as the random
;;generator is now more limited.
(defun guess-within-bounds (guess colors code-length)
	(setf randoms-needed (- code-length (+ (car (cdr *best-guess*)) (car (cdr (cdr *best-guess*))))))
	(setf colors-for-space (copy-list (car *best-guess*)))
	(setf colors-confirmed (copy-list (car *best-guess*)))
	(setf valid-colors (copy-list colors))
	
	(loop for i from 0 to randoms-needed do
		(setf colors-for-space (cons nil colors-for-space)))
	
	(loop for i from 0 to (- code-length 1) do
		(setf preliminary-guess (nth (random (length colors-for-space) seed) colors-for-space))
		(setf colors-for-space (remove preliminary-guess colors-for-space :count 1))
		(cond ((null preliminary-guess) (setf (nth i guess) 
				(nth (random (length valid-colors) seed) valid-colors)))
			  (t (setf (nth i guess) preliminary-guess))))
			  
	(return-from guess-within-bounds guess))
	
;;Function: check-knowledge
;;
;;check-knowledge deals with invalid guesses, and runs throguh the entire knowledge
;;base checking for duplicate guesses first, and invalid red/white scores second.
;;It will only return T, paving the way for testing a new guess, if nothing in this
;;function returns nil. Otherwise, the current guess is invalid and a new one must be
;;tested.
(defun check-knowledge (guess knowledge)
	(setf valid-guess t)
	(loop for i from 0 to (- (length knowledge) 1) do
		(setf knowledge-bite (pop knowledge))
		(cond ((null valid-guess) (return-from check-knowledge valid-guess))
			  ((null (check-repeated guess knowledge-bite)) (return-from check-knowledge nil))
			  ((null (check-prev guess knowledge-bite)) (setf valid-guess nil))
			  ))
	(return-from check-knowledge valid-guess))

;;Function: check-repeated
;;
;;check-repeated simply takes a guess and a piece of the knowledge base and checks
;;for equality. If they aren't equal, it returns T. If they are equal, it returns NIL,
;;and a new guess must be generated.
(defun check-repeated (guess knowledge-bite)
	(setf not-repeated t)
	(cond ((equal guess (car knowledge-bite)) (setf not-repeated nil)))
	(return-from check-repeated not-repeated)) 

;;Function: check-prev
;;
;;This function takes care of checking the red/white scores of a current
;;guess and a previous guess. First it checks reds. If at least R spaces
;;match up between a current guess and a previous guess, where R is the
;;red score for the previous guess, then the current guess is valid so far.
;;Then it checks whites with a similar process, and only returns T if
;;the number of reds and whites are both consistent with previous guesses.
(defun check-prev (guess knowledge-bite)
	(setf reds (car (cdr knowledge-bite)))
	(setf whites (car (cdr (cdr knowledge-bite))))
	(setf prev-guess (copy-list (car knowledge-bite)))
	(setf new-guess (copy-list guess))
	
	(cond ((>= (+ reds whites) (+ (car (cdr *best-guess*)) (car (cdr (cdr *best-guess*))))) 
			(setf *best-guess* knowledge-bite)))
	
	(loop for i from 0 to (- reds 1) do
		(setf found-red nil)
		(loop for j from 0 to (- (length new-guess) 1) do
		  (cond ((and (eql (nth j new-guess) (nth j prev-guess)) (null found-red))
		  	(setf (nth j new-guess) nil)
		  	(setf found-red t)
		  	)))
		 		
		(if (null found-red)
		 (return-from check-prev nil)))
		 
	(loop for i from 0 to (- whites 1) do
		(setf found-white nil)
		(loop for j from 0 to (- (length new-guess) 1) do
		  (loop for k from 0 to (- (length prev-guess) 1) do
				(cond ((and (eql (nth j new-guess) (nth k prev-guess)) (null found-white))
					(setf (nth j new-guess) nil)
					(setf found-white t)
					))))
		 		
		(if (null found-white)
		 (return-from check-prev nil)))
	(return-from check-prev t))

;; Function: update-possible-colors
;;
;; A function that is used in the case that either all colors
;; of a code are present in a guess or no colors are present
;; in a guess. It trims the list of valid colors accordingly.
(defun update-possible-colors (guess guess-results possible-colors code-length)
	(setf colors nil)
	(cond ((equal (+ (car guess-results) (car (cdr guess-results))) code-length)
					(loop for i from 0 to (- (length guess) 1) do
						(setf colors (append colors (list (nth i guess))))))
		  ((equal (+ (car guess-results) (car (cdr guess-results))) 0)
					(loop for i from 0 to (- (length possible-colors) 1) do
						(setf color-absent t)
						(loop for j from 0 to (- (length guess) 1) do
							(cond ((equal (nth i possible-colors) (nth j guess))
										(setf color-absent nil))))
						(cond ((equal color-absent t)
									 (setf colors (append colors (list (nth i possible-colors))))))))
		  (t (setf colors (copy-list possible-colors))))
	(return-from update-possible-colors colors))
	
;;Function: clear
;;
;;Helper function to clear the global variables,
;;used in debugging and the main function at the end of a tournament round.
(defun clear ()
	(setf *knowledge* nil)
	(setf *best-guess* nil)
	(setf *possible-colors* nil))
